home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-19 / surfsrc3.zip / SURFGRAF.PAS < prev    next >
Pascal/Delphi Source File  |  1991-11-09  |  34KB  |  1,155 lines
  1. {$I defines.inc}
  2. Unit SURFGRAF;
  3. {Graphics primitives for Surfmodl.  These primitives use the borland .BGI }
  4. {routines.  If you add support for a new graphics system, you must update }
  5. {the SYS_NAME, LGLSYS, MAXSYS, and perhaps OLDSYS routines.  You also must}
  6. {update the SURFBGI bgi emulation routines}
  7.  
  8. INTERFACE
  9. uses dos, crt,
  10.   SHAREDEC,
  11. {$IFDEF EXTERNAL}
  12.   SURFbgi;
  13. {$ELSE}
  14.   Graph;
  15. {$ENDIF}
  16.  
  17. {$IFDEF USE8087}
  18. type real = single;
  19. {$ENDIF}
  20. { Names of all the systems currently supported by SURFMODL: }
  21. const VGA256 = 6;         { shared with IBM8514 }
  22.       MAXSYS = 11;        { maximum # of systems currently supported }
  23.  
  24.  
  25. const Sys_name: array[1..MAXSYS] of string[30] = (
  26.         'IBM Color Graphics Adapter',
  27.         'IBM MCGA Graphics Adapter',
  28.         'IBM Enhanced Graphics Adapter',
  29.         'IBM EGA with 64K memory',
  30.         'IBM EGA with Mono Display',
  31.         'VGA With 256-Color Capability',
  32.         'Hercules Mono Graphics Adapter',
  33.         'AT&T 6300 400 line mode',
  34.         'IBM VGA Graphics Adapter',
  35.         'IBM 3270',
  36. {$IFDEF VAXMATE }
  37.         'DEC Vaxmate'
  38. {$IFDEF USE_IFF}
  39.   ERROR - YOU CAN NOT DEFINE BOTH VAXMATE AND USE_IFF
  40. {$ENDIF}
  41. {$ELSE}
  42. {$IFDEF USE_IFF}
  43.         'AMIGA IFF'
  44. {$ELSE}
  45.         'RESERVED'   {<<<<<< Note, this must be present and in CAPS to work}
  46. {$ENDIF}
  47. {$ENDIF}
  48.  
  49.          );
  50.  
  51.  
  52. const RESERVED = 11;  { TP 5.0 & above no longer have a RESERVED type }
  53.  
  54.  
  55.       LGLSYS: array[1..MAXSYS] of integer = (
  56.         CGA,
  57.         MCGA,
  58.         EGA,
  59.         EGA64,
  60.         EGAMONO,
  61.         VGA256,
  62.         HERCMONO,
  63.         ATT400,
  64.         VGA,
  65.         PC3270,
  66. {$IFDEF VAXMATE}  {Make unused systems RESERVED}
  67.         VM400
  68. {$ELSE}
  69. {$IFDEF USE_IFF}
  70.         IFF
  71. {$ELSE}
  72.         RESERVED
  73. {$ENDIF}
  74. {$ENDIF}
  75.         );
  76.  
  77. {table to convert old Surfmodl 1.x system number to new}
  78. const oldsys :array[1..10] of integer = (
  79.          CGA,      { CGA      : old number 1}
  80.          EGA,      { EGA      : old number 2}
  81.          HERCMono, { HERCMono : old number 3}
  82.          detect,   { Sanyo Unsupported, try to detect}
  83.          detect,   { Heath/Zenith Z-100 Unsupported, try to detect }
  84.          CGA,      { Toolbox CGA, old number 6 }
  85.          ATT400,   { AT&T 6300 mode, old number 7 }
  86.          PC3270,   { IBM 3270, old number 8 }
  87.          EGA64,    { Old QUADEGA (640x480), closest is (640x350) }
  88.          EGA64);   { Old QUADEGA (752x410), closest is (640x350) }
  89.  
  90.  
  91. var
  92.   driveron  : boolean;   { flag for if driver is on or not }
  93.   grsys     : integer;   { Graphics system being used      }
  94.   grmode    : integer;   { Graphics mode in the system     }
  95.   dorandom  : boolean;   { flag for random interpolation   }
  96.   RandShade : real;      { Random shade pattern }
  97.   Ngraphchar: integer;   { #chars across graphics screen}
  98.                          { If 0 then no text will be
  99.                            displayed on the graphics screen }
  100.   Gxmin,  Gxmax,
  101.   Gymin, Gymax: integer; { graphics screen limits }
  102.   ncolors   : integer;   { Number of colours supported in current mode}
  103.   MONO      : boolean;   { Flag for monochrome graphics }
  104.   Viewchanged : boolean; { Flag for changed viewpoint }
  105.   Flpurpose : string[127]; { title for plot }
  106.   BGIDIR    : string;    { directory for BGI files }
  107.   Textcol   : integer;   { color to display text on text screen }
  108.   BGcol     : integer;   { background color for text display }
  109.   Graphcol  : integer;   { color to display text on graphics screen }
  110.   RevVideo  : boolean;   { reverse video? }
  111.   ShowTitle : boolean;   { display title on plot? }
  112. {$ifdef DEBUG}
  113.   Dbgfile   : text;      { debugging file }
  114. {$endif}
  115.  
  116. { NEW VARIABLES FOR THE FULL-PALETTE MATERIAL DEFINITION: }
  117. const MAXSHADES = 32;    { maximum # of shades to be plotted per matl }
  118. {$IFDEF USE_IFF}
  119.   RESERVED_COLORS = 2;   { # of reserved colors on Amiga }
  120. {$ELSE}
  121.   RESERVED_COLORS = 16;  { # of reserved colors in VGA 256-color mode }
  122. {$ENDIF}
  123.  
  124. type matlarray = array[1..MAXMATL] of integer;
  125.  
  126. var
  127.   RGB_levels: integer;   { assigned for each device - max #
  128.                            distinguishable levels in EACH of the red,
  129.                            green & blue components (= 63 on VGA, 255 on Amiga)
  130.                            NOTE the Amiga really only has 15 RGB levels, but
  131.                            for IFF format all values are 0..255.
  132.                          }
  133.   Maxcol_mat: integer;   { max # colors used in palette for each matl }
  134.   Ncol_mat: matlarray;   { actual # colors used by each matl }
  135.   { The following set of variables is only used by devices with a large
  136.     color palette (like the VGA and Amiga). The new data file format
  137.     permits specification of an RGB value for each material. This value is
  138.     specified as an integer in the range from 0..255 with 255 corresponding
  139.     to full intensity.  Even though none of the currently-supported devices
  140.     in SURFMODL have a color range this large, this is always the range used
  141.     in the data file.  Internally, this number is scaled to the proper range
  142.     for the device you are using (0..63 for the VGA and 0..15 for the Amiga).
  143.     If an old data file format is used (and therefore the RGB values
  144.     are not entered), then the full palette of the devices is still supported
  145.     by automatically using a table of RGB values for the standard colors of
  146.     the PC.  Note that you can also specify RGB levels through the Lighting
  147.     Menu.  Also note that these RGB numbers are ignored if you are using a
  148.     device other than the VGA or Amiga, and the old color #'s are used.
  149.   }
  150.   VGApal: SurfPalette; { The full VGA palette }
  151.  
  152. procedure gplot (x,y,color:integer);
  153. procedure exgraphic;
  154. procedure closedriver; {shuts down entire graphics system }
  155. procedure GDRAW (X1t, Y1t, X2t, Y2t, Color: integer);
  156. procedure GHDRAW  (X1, X2, Y, Color: integer);
  157. procedure SHPLOT (X, Y, Color: integer; Fmod: integer);
  158. procedure SHDRAW (X1, X2, Y, Color: integer; Fmod: integer);
  159. procedure SETSYS;
  160. procedure SELECT_SYS;
  161.  
  162. procedure SETGMODE (Nmatl: integer);
  163. procedure stopstat;
  164. function grafstat : boolean;
  165. function checkey : boolean;
  166. procedure puttext (X, Y: integer; textstring: string; color: integer);
  167. function width_of_text (textstring: string): integer;
  168. function height_of_text (textstring: string): integer;
  169.  
  170.  
  171. function savescrn (filename : string) : boolean;
  172. (* KVC Removed:
  173. function readscrn (filename : string; var grsys,grmode : integer;
  174.     var image : picbuf; var nbuf : integer; var nlines_buf : nlpic;
  175.     var vgapalette : SurfPalette; oldgrsys, oldgrmode : integer) : boolean;
  176. *)
  177. procedure VGASetAllPalette (var P : SurfPalette);
  178. procedure Abort(Msg : string);
  179. function DetectVGA256 : integer;
  180. procedure def_palette (Nmatl: integer);
  181. procedure findcolors (Mat, Matcolor: integer; var Shade: real; var Color1, Color2:
  182.   integer);
  183. procedure color_to_rgb (Color: integer; var Red, Grn, Blu: integer);
  184.  
  185. IMPLEMENTATION
  186.  
  187. {$I PALETTE.INC}
  188.  
  189. procedure gplot (x,y,color:integer);
  190. {plot one dot in given colour, with clipping}
  191. begin
  192.   putpixel (x,y,color);
  193. end;
  194.  
  195. procedure EXGRAPHIC;
  196. { Exit graphics mode }
  197. begin
  198.   RestoreCrtMode;
  199. end;  { procedure EXGRAPHIC }
  200.  
  201. procedure closedriver;
  202. { closes down the existing graphics system }
  203. begin
  204.   if driveron then begin
  205.     setgraphmode(grmode);
  206.     closegraph;
  207.     driveron := false;
  208.   end;
  209. end;
  210.  
  211. { NOTE: This file contains several routines, which are the system-independent
  212.   graphics primitives of SURFMODL:
  213.     GDRAW       - Line drawing routine
  214.     GHDRAW      - Horizontal line drawing routine
  215.     SHPLOT      - Shaded pixel plot routine
  216.     SHDRAW      - Shaded line drawing routine
  217.     DITHPLOT    - Dithered pixel plot routine
  218.     DITHDRAW    - Dithered line drawing routine
  219.     INTRPLOT    - Interpolated pixel plot routine
  220.     INTRDRAW    - Interpolated line drawing routine
  221. }
  222.  
  223.  
  224. procedure GDRAW (X1t, Y1t, X2t, Y2t, Color: integer);
  225. { This routine was written by Russell Nelson, to draw a line using the
  226.   GPLOT primitive -- for systems that do not provide a line drawing
  227.   primitive. This routine does NOT clip. }
  228. var
  229.   delta_x, delta_y : integer;
  230.   inc_x, inc_y : integer;
  231.   epsilon, count : integer;
  232.   x1, y1, x2, y2: integer;
  233. begin
  234.   if (x2t < x1t) then begin
  235.     { Make sure the lines are always plotted in the same direction, for
  236.       smooth line drawing in hidden line removal. }
  237.     x1 := x2t;
  238.     y1 := y2t;
  239.     x2 := x1t;
  240.     y2 := y1t;
  241.   end else begin
  242.     x1 := x1t;
  243.     y1 := y1t;
  244.     x2 := x2t;
  245.     y2 := y2t;
  246.   end;
  247.   delta_x := abs(x2 - x1);
  248.   delta_y := abs(y2 - y1);
  249. {  if x2 > x1 then inc_x := 1 else inc_x := -1; }
  250.   inc_x := 1;
  251.   if y2 > y1 then inc_y := 1 else inc_y := -1;
  252.   if delta_x > delta_y then begin
  253.     count := delta_x + 1;
  254.     epsilon := delta_x div 2;
  255.     while count>0 do begin
  256.       GPLOT(x1, y1, Color);
  257.       epsilon := epsilon + delta_y;
  258.       if epsilon > delta_x then begin
  259.         epsilon := epsilon - delta_x;
  260.         y1 := y1 + inc_y;
  261.       end;
  262.       x1 := x1 + inc_x;
  263.       count := count - 1;
  264.     end;
  265.   end else begin
  266.     count := delta_y + 1;
  267.     epsilon := delta_y div 2;
  268.     while count>0 do begin
  269.       GPLOT(x1, y1, Color);
  270.       epsilon := epsilon + delta_x;
  271.       if epsilon > delta_y then begin
  272.         epsilon := epsilon - delta_y;
  273.         x1 := x1 + inc_x;
  274.       end;
  275.       y1 := y1 + inc_y;
  276.       count := count - 1;
  277.     end;
  278.   end;
  279. end; { procedure GDRAW }
  280.  
  281.  
  282. { GHDRAW: Horizontal line draw.}
  283. procedure GHDRAW  (X1, X2, Y, Color: integer);
  284. begin
  285.  gdraw (x1,y,x2,y,color);
  286. end; { procedure GHDRAW }
  287.  
  288. procedure SHPLOT (X, Y, Color: integer; Fmod: integer);
  289. { system-independent shaded pixel plot command }
  290. { This routine uses the system's colors as shades of grey }
  291. begin
  292.   if (Fmod > 1) then begin
  293.     if (X mod Fmod = Y mod Fmod) then
  294.       gplot (X, Y, Color)
  295.     else
  296.       gplot (X, Y, 0);
  297.   end else if (Fmod < -1) then begin
  298.     if (X mod -Fmod = Y mod -Fmod) then
  299.       gplot (X, Y, 0)
  300.     else
  301.       gplot (X, Y, Color);
  302.   end else
  303.     gplot (X, Y, Color);
  304. end; { procedure SHPLOT }
  305.  
  306. procedure SHDRAW (X1, X2, Y, Color: integer; Fmod: integer);
  307. { system-independent shaded horizontal line drawing command }
  308. { This routine uses the system's colors as shades of grey }
  309. var X: integer;           { x coord }
  310.  
  311. begin
  312.   if (abs(Fmod) < 2) then
  313.     ghdraw (X1, X2, Y, Color)
  314.   else if (Fmod > 1) then begin
  315.     for X := X1 to X2 do
  316.       if (X mod Fmod = Y mod Fmod) then
  317.         gplot (X, Y, Color)
  318.       else
  319.         gplot (X, Y, 0);
  320.   end else begin
  321.     for X := X1 to X2 do
  322.       if (X mod -Fmod = Y mod -Fmod) then
  323.         gplot (X, Y, 0)
  324.       else
  325.         gplot (X, Y, Color);
  326.   end;
  327. end; { procedure SHDRAW }
  328.  
  329.  
  330. { PUTTEXT puts a text message on the graphics screen }
  331. procedure puttext (X, Y: integer; textstring: string; color: integer);
  332. begin
  333.   setcolor (color);
  334.   outtextxy (x, y, textstring);
  335. end; { procedure PUTTEXT }
  336.  
  337. { WIDTH_OF_TEXT returns the width of a text string in pixels }
  338. function width_of_text (textstring: string): integer;
  339. begin
  340.   width_of_text := textwidth (textstring);
  341. end; { function WIDTH_OF_TEXT }
  342.  
  343. { HEIGHT_OF_TEXT returns the height of a text string in pixels }
  344. function height_of_text (textstring: string): integer;
  345. begin
  346.   height_of_text := textheight (textstring);
  347. end; { function HEIGHT_OF_TEXT }
  348.  
  349.  
  350. procedure SETSYS;
  351. { Initialize system-dependent parameters }
  352. var grtmp: integer;
  353.     grmtmp: integer;
  354.     success : boolean;
  355.  
  356. begin
  357. {$IFDEF USE_IFF}
  358.   { Have to use the IFF driver if compiled for it. }
  359.   if grsys <> IFF then begin
  360.     writeln('ERROR: GRSYS must be ', IFF, ' in SURFIFF.CFG');
  361.     halt;
  362.   end;
  363. {$ENDIF}
  364.   success := true;
  365.  
  366. {$IFNDEF EXTERNAL}
  367.   { KVC 04/20/91 Make Turbo recognize the SVGA256.BGI file }
  368.   grtmp := InstallUserDriver('SVGA256', @DetectVGA256);
  369. {$ENDIF}
  370.   { KVC 09/11/91 This call to detect shouldn't be necessary, but otherwise
  371.     Turbo does not seem to be using the SVGA256.BGI file.
  372.   }
  373.   grtmp := detect;
  374.   grmtmp := 0;
  375.   if (grsys <> VGA256) then
  376.     grtmp := grsys;
  377.   initgraph (grtmp,grmtmp,BGIDIR);
  378.   if (graphresult < 0) then
  379.     success := false
  380.   else begin
  381.     { Have to go into graphics mode to read the parameters: }
  382.     setgraphmode(grmode);
  383.     if (graphresult < 0) then
  384.       success := false
  385.     else begin
  386.       ngraphchar := GetMaxX div textwidth ('Z');
  387.       GXmin := 0;
  388.       GXMax := GetMaxX ;
  389.       Gymin := 0;
  390.       GYMax := GetMaxY;
  391.       Ncolors := GetMaxColor;
  392.       viewchanged := true;
  393.       driveron := true;
  394.       restorecrtmode;
  395.       if (graphresult < 0) then
  396.         success := false;
  397.     end;
  398.   end;
  399.  
  400.   if (not success) then begin
  401.     writeln (grapherrormsg(grsys));
  402.     writeln;
  403.     writeln ('If the .BGI files are not in the current directory');
  404.     writeln ('then you can use SET to set an environment variable');
  405.     writeln ('called BGIDIR which points to the .BGI file directory.');
  406.     writeln;
  407.     writeln ('SurfModl Halted');
  408.     halt(1);
  409.   end;
  410. end; { procedure SETSYS }
  411.  
  412. procedure SELECT_SYS;
  413. { Allow the user to select a system & mode.  This routine is only used
  414.   in installation now.
  415. }
  416. var
  417.   sys : integer;
  418.   message : string;
  419.   modelow,modehi : integer;
  420.   num : integer;
  421.   code : integer;
  422.  
  423. begin
  424.  
  425. {$IFNDEF EXTERNAL}
  426.   { KVC 04/20/91 Make Turbo recognize the VGA256.BGI file }
  427.   grsys := InstallUserDriver('SVGA256', @DetectVGA256);
  428. {$ENDIF}
  429.   grsys := detect;
  430.   grmode := 0;
  431.   initgraph (grsys,grmode,BGIDIR);
  432.   if graphresult < 0 then begin
  433.     writeln (grapherrormsg(grsys));
  434.     writeln;
  435.     writeln ('If the .BGI files are not in the current directory');
  436.     writeln ('then you can use SET to set an environment variable');
  437.     writeln ('called BGIDIR which points to the .BGI file directory.');
  438.     writeln;
  439.     writeln ('SurfModl Halted');
  440.     halt(1);
  441.   end;
  442.  
  443.   {Write the menu options}
  444.   restorecrtmode;
  445.   clrscr;
  446.  
  447.   writeln;
  448.   writeln ('Choose from the following system types:');
  449.   for Sys := 1 to MAXSYS do
  450.     if (Sys_name[lglsys[sys]] <> 'RESERVED') then
  451.       writeln (Lglsys[Sys]:3,' ',Sys_name[Lglsys[Sys]]);
  452.  
  453.   repeat
  454.     write ('System Number [Hit Enter to use default of ',grsys,']: ');
  455.     readln (message);
  456.     if message = '' then
  457.       str (grsys,message);
  458.     val(message,num,code);
  459.   until ((code = 0) and (trunc(num) in [1..MAXSYS]) and
  460.           (SYS_NAME[lglsys[num]] <> 'RESERVED'));
  461.   grsys := trunc(num);
  462.  
  463.   {Get mode for this driver}
  464.   clrscr;
  465.  
  466.   getmoderange(grsys,modelow,modehi);
  467.   if modelow <> modehi then begin {Select the graphics mode}
  468.     writeln ('Choose from the following graphics modes:');
  469.     Case grsys of
  470.       CGA : begin
  471.         writeln (' 0: 320x200, Lightgreen Lightred, Yellow');
  472.         writeln (' 1: 320x200, LightCyan, LightMagenta, White');
  473.         writeln (' 2: 320x200, Green, Red, Brown');
  474.         writeln (' 3: 320x200, Cyan, Magenta, Lightgrey');
  475.         writeln (' 4: 640x200, one colour');
  476.       end;
  477.       MCGA: Begin
  478.         writeln (' 0: 320x200, Lightgreen Lightred, Yellow');
  479.         writeln (' 1: 320x200, LightCyan, LightMagenta, White');
  480.         writeln (' 2: 320x200, Green, Red, Brown');
  481.         writeln (' 3: 320x200, Cyan, Magenta, Lightgrey');
  482.         writeln (' 4: 640x200, one colour');
  483.         writeln (' 5: 640x480, one colour');
  484.       end;
  485.       EGA : Begin
  486.         writeln (' 0: 640x200, 16 Colour');
  487.         writeln (' 1: 640x350, 16 Colour');
  488.       end;
  489.       EGA64: Begin
  490.         writeln (' 0: 640x200, 16 Colour');
  491.         writeln (' 1: 640x350, 4 Colour');
  492.       end;
  493.       EGAMONO: Begin
  494.         writeln (' 3: 640x350, 1 Colour');
  495.       end;
  496.       HercMONO: Begin
  497.         writeln (' 0: 720x348, 1 Colour');
  498.       end;
  499.       ATT400: Begin
  500.         writeln (' 0: 320x200, Lightgreen Lightred, Yellow');
  501.         writeln (' 1: 320x200, LightCyan, LightMagenta, White');
  502.         writeln (' 2: 320x200, Green, Red, Brown');
  503.         writeln (' 3: 320x200, Cyan, Magenta, Lightgrey');
  504.         writeln (' 4: 640x200, one colour');
  505.         writeln (' 5: 640x400, one colour');
  506.       end;
  507.       VGA: Begin
  508.         writeln (' 0: 640x200, 16 Colour');
  509.         writeln (' 1: 640x350, 16 Colour');
  510.         writeln (' 2: 640x480, 16 Colour');
  511.       end;
  512.       PC3270: Begin
  513.         writeln (' 0: 720x350, 1 Colour');
  514.       end;
  515.       (* KVC 04/20/91 - Removed support for IBM 8514
  516.       IBM8514: Begin
  517.         writeln (' 0: 640x850, 256 Colour');
  518.         writeln (' 1: 1024x768 256 Colour');
  519.       end;
  520.       *)
  521.           VGA256: Begin
  522.             writeln (' 0: Standard VGA    (320x200, 256 Colour)');
  523.         writeln (' 1: Super VGA  256k (640x400, 256 Colour)');
  524.         { Not all VGA's can display all modes, because some don't have
  525.           enough memory:
  526.         }
  527.         if modehi >= 2 then
  528.           writeln (' 2: Super VGA  512k (640x480, 256 Colour)');
  529.         if modehi >= 3 then
  530.           writeln (' 3: Super VGA  512k (800x600, 256 Colour)');
  531.         if modehi >= 4 then
  532.           writeln (' 4: Super VGA 1024k (1024x768, 256 Colour)');
  533.           end;
  534. {$IFDEF VAXMATE} {DEC VAXMATE modes}
  535.       VM400 : begin
  536.         writeln (' 0: 320x200, Lightgreen Lightred, Yellow');
  537.         writeln (' 1: 320x200, LightCyan, LightMagenta, White');
  538.         writeln (' 2: 320x200, Green, Red, Brown');
  539.         writeln (' 3: 320x200, Cyan, Magenta, Lightgrey');
  540.         writeln (' 4: 640x200, one colour');
  541.         writeln (' 5: 640x400, four colour');
  542.         writeln (' 6: 640x400, one colour');
  543.       end;
  544. {$ENDIF}
  545.     end; {case}
  546.  
  547.     grmode := modehi;
  548.     repeat
  549.       write ('Enter Graphic Mode [',grmode,']: ');
  550.       readln (message);
  551.       if message = '' then
  552.         str (grmode,message);
  553.       val(message,num,code);
  554.     until ((code = 0) and (trunc(num) in [modelow..modehi]));
  555.     grmode := trunc(num);
  556.  
  557.   end; { if modelow <> modehi }
  558.  
  559. end; { procedure SELECT_SYS }
  560.  
  561.  
  562. function CHECKEY: boolean;
  563. { Return TRUE if the 'A' key has been pressed, or FALSE otherwise }
  564. var c: char;
  565.  
  566. begin
  567.   c := ' ';
  568.   if (keypressed) then begin
  569.     c := readkey;
  570.     if (upcase (c) = 'A') then
  571.       Checkey := TRUE
  572.     else
  573.       Checkey := FALSE;
  574.   end else
  575.     Checkey := FALSE;
  576. end; { function CHECKEY }
  577.  
  578. { GRAFSTAT and STOPSTAT control the plotting of "status dots" at the bottom
  579.   of the graphics screen.  STOPSTAT clears the line away and also
  580.   reinitializes the local (static) variables.
  581. }
  582. var Statpos: integer;   { next X-position to plot a status dot }
  583.  
  584. procedure STOPSTAT;
  585. var c: char;
  586. begin
  587. {$IFDEF USE_IFF}
  588.   if Grsys <> IFF then begin
  589. {$ENDIF}
  590.   Statpos := Gxmin+3;
  591.   gdraw (Gxmin+1, Gymax-1, Gxmax-1, Gymax-1, 0);
  592. {$IFDEF USE_IFF}
  593.   end;
  594. {$ENDIF}
  595.   { Clear out the console input buffer }
  596.   while (keypressed) do
  597.     c := readkey;
  598. end; { procedure STOPSTAT }
  599.  
  600. function GRAFSTAT: boolean;
  601. { Every call to GRAFSTAT produces a new status dot, and also
  602.   checks the keyboard for a run abort.  GRAFSTAT returns TRUE if the
  603.   user wishes to abort the run (by pressing the 'A' key), or FALSE otherwise.
  604. }
  605. begin
  606. {$IFDEF USE_IFF}
  607.   if Grsys <> IFF then begin
  608. {$ENDIF}
  609.   Statpos := Statpos + 1;
  610.   if (Statpos > Gxmax-3) then
  611.     stopstat;
  612.   gplot (Statpos, Gymax-1, 1);
  613. {$IFDEF USE_IFF}
  614.   end;
  615. {$ENDIF}
  616.   Grafstat := checkey;
  617. end; { procedure GRAFSTAT }
  618.  
  619.  
  620.  
  621. procedure SETGMODE (Nmatl: integer);
  622.  
  623. { Set up graphics mode and draw the window }
  624. var
  625.   message: string;
  626.   temp : integer;
  627.  
  628. begin
  629.  
  630.   setgraphmode(grmode);
  631.   temp := (graphresult);
  632.   message := grapherrormsg(temp);
  633.   if message <> 'No error' then begin
  634.     restorecrtmode;
  635.     writeln;
  636.     writeln ('SETGraphMODE: BGI error: ',message);
  637.     writeln ('Error number: ',temp);
  638.     writeln ('GrSys is: ',Grsys);
  639.     writeln ('GrMode is: ',Grmode);
  640.     writeln ('SurfModl Halted');
  641.     halt;
  642.   end else begin
  643.  
  644.     RGB_levels := 1;
  645.     if grsys = VGA256 then
  646.       RGB_levels := 63
  647. {$ifdef USE_IFF}
  648.     else if grsys = IFF then
  649.       RGB_levels := 255
  650. {$endif}
  651.     ;
  652.  
  653.     if Nmatl > 0 then
  654.       def_palette (Nmatl);
  655.  
  656.     gdraw (Gxmin, Gymin, Gxmax, Gymin, 1);
  657.     gdraw (Gxmax, Gymin, Gxmax, Gymax, 1);
  658.     gdraw (Gxmax, Gymax, Gxmin, Gymax, 1);
  659.     gdraw (Gxmin, Gymax, Gxmin, Gymin, 1);
  660.  
  661.     stopstat;  { Initialize the graphics status line }
  662.  
  663.     if ngraphchar < length (Flpurpose) then
  664.       flpurpose := copy (Flpurpose,1,ngraphchar);
  665.  
  666.     if ShowTitle then
  667.       puttext ((ngraphchar - length(Flpurpose)) * 4, 10, Flpurpose, Graphcol);
  668.   end; {else}
  669. end; { procedure SETGMODE }
  670.  
  671.  
  672.  
  673.  
  674. function savescrn (filename : string) : boolean;
  675. { Save the current graphics screen image to disk.
  676.   KVC 8/31/91 Modified to save screens larger than 64K
  677. }
  678. var
  679.   imagefile     : file;
  680.   bitmap        : pointer;
  681.   success       : boolean;
  682.   nbytes        : longint;
  683.   nbytes_alloc  : longint;
  684.   xmax, ymax    : integer;
  685.   y1, y2        : integer;
  686.   nbytes_line   : longint;
  687.   nlines        : longint;
  688. {$IFDEF DEBUG}
  689.   tot_nbytes    : longint;
  690. {$ENDIF}
  691.  
  692. begin
  693.   success := true;
  694.  
  695.   { First we find out how many bytes in one line of the screen, since the
  696.     full screen may require more than 64K bytes and we can't allocate that
  697.     much all at once.
  698.   }
  699.   xmax := GetMaxX;
  700.   ymax := GetMaxY;
  701.   if (Grsys = VGA256) then
  702.     { Bug in SVGA256 doesn't set imagesize correctly }
  703.     nbytes_line := xmax + 5
  704.   else
  705.     nbytes_line := imagesize (0, 0, xmax, 0);
  706. {$IFDEF DEBUG}
  707.   tot_nbytes := 0;
  708. {$ENDIF}
  709.  
  710.   { Find out how many lines we can fit in a 64K buffer.  Note that this
  711.     is a conservative estimate, since in fact there is a 4-byte header
  712.     included in every imagesize calculation (and therefore every
  713.     getimage/putimage too).  The actual number of lines we can fit in a
  714.     64K buffer is larger than this, but we'll settle for the small loss
  715.     of speed to avoid making any assumptions about the header.
  716.   }
  717.   if (nbytes_line * (ymax+1) > MAXALLOC) then
  718.     nlines := MAXALLOC div nbytes_line
  719.   else
  720.     nlines := ymax + 1;
  721.  
  722.   { Allocate storage }
  723.   nbytes_alloc := nlines * nbytes_line;
  724.   getmem (bitmap, nbytes_alloc);
  725.  
  726.   if bitmap = nil then {error}
  727.     success := false
  728.   else begin
  729.     {$I-}
  730.     assign (imagefile,filename);
  731.  
  732.     if ioresult <> 0 then
  733.       success := false;
  734.  
  735.     rewrite (imagefile,1);
  736.     if ioresult <> 0 then
  737.       success := false;
  738.     
  739.     y1 := 0;
  740.     y2 := nlines - 1;
  741.  
  742.     { Write the graphics adapter type & mode first: }
  743.     blockwrite (imagefile,grsys,sizeof(grsys));
  744.     if ioresult <> 0 then
  745.       success := false;
  746.  
  747.     blockwrite (imagefile,grmode,sizeof(grmode));
  748.     if ioresult <> 0 then
  749.       success := false;
  750.  
  751.     if (grsys = VGA256) then begin
  752.       { Have to save the VGA palette too }
  753.       blockwrite (imagefile, VGApal, sizeof(VGApal));
  754.       if ioresult <> 0 then
  755.         success := false;
  756.     end;
  757.  
  758.     while (success) and (y1 <= y2) do begin
  759.  
  760.       if (Grsys = VGA256) then
  761.         { Bug in SVGA256 doesn't set imagesize correctly }
  762.         nbytes := (xmax+1) * (y2-y1+1) + 4
  763.       else
  764.         nbytes := imagesize (0, y1, xmax, y2);
  765.       if (nbytes > nbytes_alloc) then
  766.         { Whoops, we didn't get enough storage }
  767.         success := false
  768.       else begin
  769. {$IFDEF DEBUG}
  770.         tot_nbytes := tot_nbytes + nbytes;
  771. {$ENDIF}
  772.         getimage (0, y1, xmax, y2, bitmap^);
  773.         if (graphresult = GrOK) AND (bitmap <> nil) then begin
  774.  
  775.           { Show what we just got in reverse video }
  776.           putimage (0, y1, bitmap^, NOTput);
  777.           if (graphresult <> GrOK) then
  778.             success := false
  779.           else
  780.             blockwrite (imagefile, bitmap^, nbytes);
  781.           if ioresult <> 0 then
  782.             success := false;
  783.  
  784.           y1 := y1 + nlines;
  785.           y2 := y2 + nlines;
  786.           if (y2 > ymax) then
  787.             y2 := ymax;
  788.           { Put it back in normal video }
  789.           putimage (0, y1 - nlines, bitmap^, NormalPut);
  790.         end else
  791.           success := false;
  792.       end; { if nbytes > nbytes_alloc }
  793.     end; { while }
  794.  
  795.     close (imagefile);
  796.     if ioresult <> 0 then
  797.       success := false;
  798.     {$I+}
  799.  
  800.     release (bitmap);
  801.   end; { if bitmap = nil }
  802.  
  803.   savescrn := success;
  804. end; {savescrn}
  805.  
  806.  
  807. {$ifdef NEVER}
  808.    KVC Removed readscrn from SURFGRAF.PAS because we don't want all
  809.    the extra baggage associated with XMS to be carried with SURFMODL:
  810.  
  811. function readscrn (filename : string; var grsys,grmode : integer;
  812.     var image : picbuf; var nbuf : integer; var nlines_buf : nlpic;
  813.     var vgapalette : SurfPalette; oldgrsys, oldgrmode : integer) : boolean;
  814. var
  815.   imagefile   : file;
  816.   success     : boolean;
  817.   nbytes      : longint;
  818.   tmp         : real;
  819.   xmax        : integer;
  820.   ymax        : integer;
  821.   nbytes_line : longint;
  822.   y1, y2      : integer;
  823.   grtmp       : integer;
  824.   grmtmp      : integer;
  825.  
  826. begin
  827.   success := true;
  828.   {$I-}
  829.   assign (imagefile,filename);
  830.  
  831.   if ioresult <> 0 then begin
  832.     success := false;
  833.     writeln ('File "',filename,'" not found');
  834.   end;
  835.  
  836.   reset (imagefile,1);
  837.   if ioresult <> 0 then begin
  838.     success := false;
  839.     writeln ('File "',filename,'" not found');
  840.   end;
  841.  
  842.   blockread (imagefile,grsys,sizeof(grsys));
  843.   if ioresult <> 0 then begin
  844.     success := false;
  845.     writeln ('Could not read grsys');
  846.   end;
  847.  
  848.   blockread (imagefile,grmode,sizeof(grmode));
  849.   if ioresult <> 0 then begin
  850.     success := false;
  851.     writeln ('Could not read grmode');
  852.   end;
  853.  
  854.   if (grsys = VGA256) then begin
  855.     { Have to restore the VGA palette too }
  856.     blockread (imagefile, vgapalette, sizeof(vgapalette));
  857.     if ioresult <> 0 then begin
  858.       success := false;
  859.       writeln ('Could not read VGA palette');
  860.     end;
  861.   end;
  862.  
  863.   {$I+}
  864.  
  865.  
  866.   if success then begin
  867.     { Have to go into graphics mode to read line size }
  868.     if (grsys <> oldgrsys) then begin
  869.       if (oldgrsys <> -1) then
  870.         { Not the first time, exit graphics mode first }
  871.         closegraph;
  872. {$IFNDEF EXTERNAL}
  873.       { KVC 04/20/91 Make Turbo recognize the SVGA256.BGI file }
  874.       grtmp := InstallUserDriver('SVGA256', @DetectVGA256);
  875. {$ENDIF}
  876.       { KVC 09/11/91 This call to detect shouldn't be necessary, but otherwise
  877.           Turbo does not seem to be using the SVGA256.BGI file.
  878.       }
  879.       grtmp := detect;
  880.       grmtmp := 0;
  881.       if (grsys <> VGA256) then
  882.           grtmp := grsys;
  883.       initgraph (grtmp,grmtmp,BGIDIR);
  884.       if (grsys = VGA256) then
  885.         { Set the palette }
  886.         VGASetAllPalette (vgapalette);
  887.     end else if (grmode <> oldgrmode) then
  888.       setgraphmode (grmode);
  889.  
  890.     xmax := GetMaxX;
  891.     ymax := GetMaxY;
  892.     if (Grsys = VGA256) then
  893.       { Bug in SVGA256 doesn't set imagesize correctly }
  894.       nbytes_line := xmax + 5
  895.     else
  896.       nbytes_line := imagesize (0, 0, xmax, 0);
  897.  
  898.     { Find out how many lines we can fit in a 64K buffer }
  899.     if (nbytes_line * (ymax+1) > MAXALLOC) then
  900.       nlines_buf[1] := MAXALLOC div nbytes_line
  901.     else
  902.       nlines_buf[1] := ymax + 1;
  903.  
  904.     y1 := 0;
  905.     y2 := nlines_buf[1] - 1;
  906.     nbuf := 0;
  907.  
  908.     { The following loop is done once per buffer }
  909.     while (success) and (y1 <= y2) do begin
  910.  
  911.       { Make sure we don't allocate more than we need }
  912.       nbuf := nbuf + 1;
  913.       nlines_buf[nbuf] := y2 - y1 + 1;
  914.       if (Grsys = VGA256) then
  915.         { Bug in SVGA256 doesn't set imagesize correctly }
  916.         nbytes := (xmax+1) * (y2-y1+1) + 4
  917.       else
  918.         nbytes := imagesize (0, y1, xmax, y2);
  919.  
  920.       getmem (image[nbuf], nbytes);
  921.       if (image[nbuf] = nil) then begin
  922.         success := false;
  923.         writeln ('Could not allocate memory for bitmap');
  924.       end else begin {memory successfully allocated}
  925.         {$I-}
  926.         blockread (imagefile, image[nbuf]^, nbytes);
  927.         if ioresult <> 0 then begin
  928.           success := false;
  929.           writeln ('Could not read image');
  930.         end;
  931.         {$I+}
  932.       end; {Memory allocated}
  933.  
  934.       y1 := y1 + nlines_buf[nbuf];
  935.       y2 := y2 + nlines_buf[nbuf];
  936.       if (y2 > ymax) then
  937.         y2 := ymax;
  938.  
  939.     end; { while }
  940.  
  941.   end; { Image successfully read }
  942.  
  943.   {$I-}
  944.   close (imagefile);
  945.   {$I+}
  946.   if ioresult <> 0 then
  947.     success := false;
  948.  
  949.   readscrn := success;
  950. end; {readscrn}
  951. {$endif}
  952.  
  953.  
  954. {************************************************************************}
  955. function get_env
  956.   (env_var: String)   { environment variable to look for                 }
  957.   : String;           { Value of environment variable                    }
  958. {                                                                        }
  959. {  Description:                                                          }
  960. {    Returns the value associated with the given environment variable    }
  961. {                                                                        }
  962. {************************************************************************}
  963. {                                                                        }
  964. {  Revision History:                                                     }
  965. {      "a" means Alpha version, Not Completed                            }
  966. {      "b" means Beta Test Version, Completed but in testing             }
  967. {      "c" means Completed Version.  This version is now frozen          }
  968. {                                                                        }
  969. {************************************************************************}
  970.  
  971. var
  972.   i,j: integer;
  973.   result: String;
  974.   found: boolean;
  975.   table_address: integer;
  976.  
  977. begin  { get_environment }
  978.   result := '';
  979.   i := 0;
  980.   table_address := memW[PrefixSeg:$002c];
  981.  
  982.   if length (env_var) <> 0 then begin
  983.     for j := 1 to length(env_var) do begin {convert to uppercase}
  984.       if env_var[j] in ['a'..'z'] then begin
  985.         env_var[j] := chr(ord(env_var[j])-32);
  986.       end; {then}
  987.     end; {for}
  988.  
  989.     repeat
  990.       result := '';
  991.       while (mem[table_address:i]) <> 0 do begin
  992.         result := result + chr(mem[table_address:i]);
  993.         i := i + 1;
  994.       end;
  995.  
  996.       if pos (env_var,result) = 1 then begin
  997.         found := true;
  998.         result := copy (result,length(env_var) + 2,length(result));
  999.       end
  1000.       else
  1001.         found := false;
  1002.  
  1003.       i := i + 1;
  1004.     until found or (result = '');
  1005.  
  1006.   end; { Then find value }
  1007.   get_env := result;
  1008.  
  1009. end;  {get_env}
  1010.  
  1011. { VGASetAllPalette: Set the VGA graphics palette while in 256-color mode.
  1012.   This procedure courtesy of Borland, as supplied with their VGA256
  1013.     package.
  1014. }
  1015. procedure VGASetAllPalette(var P : SurfPalette);
  1016. var
  1017.   Regs : Registers;
  1018. begin
  1019.   with Regs do
  1020.   begin
  1021.     AX := $1012;
  1022.     BX := 0;
  1023.     CX := 256;
  1024.     ES := Seg(P);
  1025.     DX := Ofs(P);
  1026.   end;
  1027.   Intr($10, Regs);
  1028. end; { VGASetAllPalette }
  1029.  
  1030. { DetectVGA256: This is the routine used when installing the VGA256
  1031.   driver for use of VGA 256-color mode.
  1032. }
  1033. {$F+}
  1034. function DetectVGA256 : integer;
  1035. var
  1036.   DetectedDriver : integer;
  1037.   SuggestedMode  : integer;
  1038. begin
  1039.   DetectGraph(DetectedDriver, SuggestedMode);
  1040.   if (DetectedDriver = VGA) or (DetectedDriver = MCGA) then
  1041.     DetectVGA256 := 0        { Default video mode = 0 }
  1042.   else
  1043.     DetectVGA256 := grError; { Couldn't detect hardware }
  1044. end; { DetectVGA256 }
  1045. {$F-}
  1046.  
  1047. { KVC 11/09/91 The following function causes getmem() to return a NIL
  1048.   when out of heap space, instead of making the program crash on Error 203.
  1049.   Thanks to Gisbert Selke for pointing out how to do this.
  1050. }
  1051. {$F+}
  1052. function HeapErrorTrap (size: word): integer;
  1053. begin
  1054.   HeapErrorTrap := 1;   { Forces new() and getmem() to return NIL }
  1055. end;
  1056. {$F-}
  1057.  
  1058. {The following procedures link in the appropriate .OBJ files so the graphics }
  1059. {drivers are always memory resident.  If you get an error message, then you  }
  1060. {must copy the .BGI files into this directory, then run the BGI2OBJ batch    }
  1061. {file.  It uses the turbo pascal 4.0 utility BINOBJ.                         }
  1062.  
  1063. {$IFDEF LINKATT}
  1064. {$DEFINE LINKING}
  1065. procedure ATTDriver; external;
  1066. {$L ATT.OBJ }
  1067. {$ENDIF}
  1068.  
  1069. {$IFDEF LINKCGA}
  1070. {$DEFINE LINKING}
  1071. procedure CgaDriver; external;
  1072. {$L CGA.OBJ }
  1073. {$ENDIF}
  1074.  
  1075. {$IFDEF LINKEGAVGA}
  1076. {$DEFINE LINKING}
  1077. procedure EgaVgaDriver; external;
  1078. {$L EGAVGA.OBJ }
  1079. {$ENDIF}
  1080.  
  1081. {$IFDEF LINKHERC}
  1082. {$DEFINE LINKING}
  1083. procedure HercDriver; external;
  1084. {$L HERC.OBJ }
  1085. {$ENDIF}
  1086.  
  1087. {$IFDEF LINKPC3270}
  1088. {$DEFINE LINKING}
  1089. procedure PC3270Driver; external;
  1090. {$L PC3270.OBJ }
  1091. {$ENDIF}
  1092.  
  1093. {$IFDEF LINKVGA256}
  1094. {$DEFINE LINKING}
  1095. {$L VGA256.OBJ }
  1096. {$ENDIF}
  1097.  
  1098. procedure Abort(Msg : string);
  1099. begin
  1100.   Writeln(Msg, ': ', GraphErrorMsg(GraphResult));
  1101.   Halt(1);
  1102. end;
  1103.  
  1104. { Following is the initialization procedure for the SURFGRAF unit.  It
  1105.   is automatically invoked when the program starts up.
  1106. }
  1107. BEGIN
  1108.   driveron := false;
  1109.   DoRandom := false;
  1110.   RandShade := 1.0 / 16.0;
  1111.   Mono := false;        { Dithering on by default }
  1112.   grsys := -1;
  1113.   grmode := -1;
  1114.   viewchanged := true;
  1115.  
  1116.   {Get the directory the .BGI drivers are in}
  1117.   BGIDIR := get_env('BGIDIR');
  1118.  
  1119.   { Force getmem to return NIL on out of heap space: }
  1120.   HeapError := @HeapErrorTrap;
  1121.  
  1122. {$IFDEF LINKCGA}
  1123.   if RegisterBGIdriver(@CGADriver) < 0 then
  1124.     Abort('CGA');
  1125. {$ENDIF}
  1126.  
  1127. {$IFDEF LINKEGAVGA}
  1128.   if RegisterBGIdriver(@EGAVGADriver) < 0 then
  1129.     Abort('EGA/VGA');
  1130. {$ENDIF}
  1131.  
  1132. {$IFDEF LINKHERC}
  1133.   if RegisterBGIdriver(@HercDriver) < 0 then
  1134.     Abort('Herc');
  1135. {$ENDIF}
  1136.  
  1137. {$IFDEF LINKATT}
  1138.   if RegisterBGIdriver(@ATTDriver) < 0 then
  1139.     Abort('AT&T');
  1140. {$ENDIF}
  1141.  
  1142. {$IFDEF LINKPC2370}
  1143.   if RegisterBGIdriver(@PC3270Driver) < 0 then
  1144.     Abort('PC 3270');
  1145. {$ENDIF}
  1146.  
  1147. { Don't need to register the VGA256 driver because it was already done. }
  1148.  
  1149. {vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv}
  1150. {If you get an error message, "Error 15: File not found (xxx.OBJ)" then you }
  1151. {must copy the .BGI files into this directory, then run the BGI2OBJ batch   }
  1152. {file.  It uses the turbo pascal 4.0 utility BINOBJ so it must be available }
  1153. {^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^}
  1154. END.
  1155.